Visual Basic Source Code/Visual Basic Source Code.iso/vbsource/dde2/ddeserve.frm

Visual Basic Form | 1993-05-16 | 7.6 KB | 242 lines

VERSION 2.00
Begin Form DDESERVER
   Caption         =   "DDE Server"
   ClientHeight    =   3660
   ClientLeft      =   1815
   ClientTop       =   1680
   ClientWidth     =   4770
   Height          =   4350
   Icon            =   DDESERVE.FRX:0000
   Left            =   1755
   LinkMode        =   1  'Source
   LinkTopic       =   "DdeServe"
   ScaleHeight     =   3660
   ScaleWidth      =   4770
   Top             =   1050
   Width           =   4890
   Begin TextBox Text2
      Height          =   2175
      Left            =   1320
      MultiLine       =   -1  'True
      TabIndex        =   2
      Top             =   960
      Width           =   3015
   End
   Begin TextBox Text1
      Height          =   375
      Left            =   1320
      TabIndex        =   0
      Top             =   360
      Width           =   3015
   End
   Begin Label lblStatus
      Height          =   255
      Left            =   0
      TabIndex        =   4
      Top             =   3360
      Width           =   4695
   End
   Begin Label Label2
      BackStyle       =   0  'Transparent
      Caption         =   "Text 2:"
      Height          =   255
      Left            =   240
      TabIndex        =   3
      Top             =   960
      Width           =   975
   End
   Begin Label Label1
      BackStyle       =   0  'Transparent
      Caption         =   "Text 1:"
      Height          =   255
      Left            =   240
      TabIndex        =   1
      Top             =   480
      Width           =   1095
   End
   Begin Menu mnuOptionsPopup
      Caption         =   "&Options"
      Begin Menu mnuOption
         Caption         =   "&Always on Top"
         Index           =   0
      End
   End
Option Explicit
Const IDM_TOPMOST = 0
' NUMEXECUTECMDS is the number of execution commands MINUS 1.
Const NUMEXECUTECMDS = 1
Const EC_DISPLAYABOUT = 0
Const EC_SHELLAPP = 1
Dim ExecuteCmd(NUMEXECUTECMDS) As String
Function Cmd_ShellApp (Params As String)
 Dim rtn As Integer
 Dim sRtn As String
 Dim appname As String
 Dim state As Integer
   ' Shell the application defined by Params
   ' First, extract the application name
   If DoExtractParam(Params, appname) Then
      ' Next extract the show state, if specified
      state = 1
      If DoExtractParam(Params, sRtn) Then
         state = Val(sRtn)
      End If
      ' Now, shell the application
      Cmd_ShellApp = Shell(appname, state)
      Exit Function
   Else
      ' No app name found
      Cmd_ShellApp = False
      Exit Function
   End If
End Function
Sub DisplayStatus (sParam As String)
   lblStatus.Caption = sParam
End Sub
Function DoExtractParam (Params As String, sRtn As String)
 Dim pStart, pEnd As Integer
 Dim rtn As Integer
   DoExtractParam = True
   ' Extract next parameter
   If Len(Params) = 0 Then
      DoExtractParam = False
      Exit Function
   End If
   ' First, extract the next parameter and update the
   ' Params string.
   rtn = InStr(1, Params, ",") ' look next for commas
   If rtn > 0 Then
      ' More parameters follow. Extract the first into
      ' 'sRtn' and update the Params string
      sRtn = LTrim$(RTrim$(Left$(Params, rtn - 1)))
      Params = Right$(Params, Len(Params) - rtn - 1)
   Else
      ' No parameters follow.
      sRtn = LTrim$(RTrim$(Params))
      Params = ""
   End If
   ' Clean up sRtn. Eliminate any leading or trailing
   ' parenthesis and blanks
   If Left$(sRtn, 1) = Chr$(34) Then
      sRtn = LTrim$(Right$(sRtn, Len(sRtn) - 1))
   End If
   If Right$(sRtn, 1) = Chr$(34) Then
      sRtn = RTrim$(Left$(sRtn, Len(sRtn) - 1))
   End If
End Function
Function DoLinkExecute (CmdStr As String)
 Dim CommandStr As String
 Dim CmdNumber As Integer
 Dim Params As String
 Dim rtn As Integer
   ' Provide for simple execution commands.
   ' Return TRUE if successful, FALSE otherwise.
   ' Make local copy of command string
   CommandStr = CmdStr
   rtn = ParseCommand(CommandStr, CmdNumber, Params)
   Do While rtn <> -1
      Select Case CmdNumber
      Case EC_DISPLAYABOUT
         MsgBox "Display About..." + Params
      Case EC_SHELLAPP
         If Cmd_ShellApp(Params) = 0 Then GoTo ExecuteError
      Case Else
      End Select
      If rtn = 0 Then
         DoLinkExecute = False
         Exit Function
      End If
      rtn = ParseCommand(CommandStr, CmdNumber, Params)
   Loop
ExecuteError:
   ' Error has occurred. Return TRUE.
   DoLinkExecute = True
End Function
Sub Form_LinkClose ()
   DisplayStatus "Link Closed"
End Sub
Sub Form_LinkError (LinkErr As Integer)
   DisplayStatus "Link Error : " + Str$(LinkErr)
End Sub
Sub Form_LinkExecute (CmdStr As String, Cancel As Integer)
   DisplayStatus "Link Execute Attempted"
   Cancel = DoLinkExecute(CmdStr)
End Sub
Sub Form_LinkOpen (Cancel As Integer)
   DisplayStatus "Link Opened"
End Sub
Sub Form_Load ()
   LoadExecuteCmds
End Sub
Sub Form_Resize ()
   lblStatus.Move 0, ScaleHeight - 255, ScaleWidth, 255
End Sub
Sub LoadExecuteCmds ()
   ' Load Execution commands into array. To add new
   ' commands, be certain to update the NUMEXECUTECMDS
   ' constant in the forms general declarations section.
   ExecuteCmd(EC_DISPLAYABOUT) = "DisplayAbout"
   ExecuteCmd(EC_SHELLAPP) = "ShellApp"
End Sub
Sub mnuOption_Click (Index As Integer)
   Select Case Index
   Case IDM_TOPMOST
      If mnuOption(Index).Checked Then
         SetWindowPos hWnd, HWND_NOTOPMOST, 0, 0, 0, 0, SWP_NOSIZE Or SWP_NOMOVE
      Else
         SetWindowPos hWnd, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOSIZE Or SWP_NOMOVE
      End If
   End Select
   ' Toggle menu checkmark
   mnuOption(Index).Checked = Not mnuOption(Index).Checked
End Sub
Function ParseCommand (CmdStr As String, CmdNumber As Integer, Params As String)
 Dim CmdStart, CmdEnd, NextCmd As Integer
 Dim pStart, pEnd As Integer
 Dim Cmd As String
 Dim ii As Integer
   ' Parse LinkExecute command and return the command number
   ' and the parameter string. Return 1 if a valid command
   ' is found, -1 if an invalid command is found, else
   ' return 0 if end of command string.
   ' Find first left square bracket. If CmdStart = 1, no bracket
   ' was found and we can assume no more commands exist so
   ' we return a 0.
   CmdStart = InStr(CmdStr, "[") + 1
   If CmdStart = 1 Then ParseCommand = 0: Exit Function
   ' If CmdEnd is -1, no following left parenthesis was found.
   ' Hence, an error was found.
   CmdEnd = InStr(CmdStart, CmdStr, "(") - 1
   If CmdEnd = -1 Then ParseCommand = -1: Exit Function
   Cmd = UCase$(LTrim$(RTrim$(Mid$(CmdStr, CmdStart, CmdEnd - CmdStart + 1))))
   pStart = InStr(CmdStart, CmdStr, "(") + 1
   pEnd = InStr(pStart, CmdStr, ")") - 1
   NextCmd = InStr(pEnd, CmdStr, "[")
   ' Find Cmd in ExecuteCmd array
   For ii = 0 To NUMEXECUTECMDS
      If UCase$(ExecuteCmd(ii)) = Cmd Then
         ' Return the command number and parameters
         Params = Mid$(CmdStr, pStart, pEnd - pStart + 1)
         CmdNumber = ii
         If NextCmd = 0 Then
            ' No following command; return 0
            ParseCommand = 0
         Else
            ' Additional commands follow. Remove this
            ' command from CmdStr and return 1.
            CmdStr = Right$(CmdStr, Len(CmdStr) - NextCmd + 1)
            ' Set the return value
            ParseCommand = 1
         End If
         Exit Function
      End If
   Next ii
   ParseCommand = -1
End Function
Sub Text1_Change ()
   DisplayStatus ""
End Sub
Sub Text2_Change ()
   DisplayStatus ""
End Sub